#' Quasi-labelling
#'
#' The first argument to every `expect_` function can use unquoting to
#' construct better labels. This makes it easy to create informative labels when
#' expectations are used inside a function or a for loop. `quasi_label()` wraps
#' up the details, returning the expression and label.
#'
#' @section Limitations:
#' Because all `expect_` function use unquoting to generate more informative
#' labels, you can not use unquoting for other purposes. Instead, you'll need
#' to perform all other unquoting outside of the expectation and only test
#' the results.
#'
#' @param quo A quosure created by `rlang::enquo()`.
#' @param label An optional label to override the default. This is
#'   only provided for internal usage. Modern expectations should not
#'   include a `label` parameter.
#' @param arg Argument name shown in error message if `quo` is missing.
#' @keywords internal
#' @return A list containing two elements:
#' \item{val}{The evaluate value of `quo`}
#' \item{lab}{The quasiquoted label generated from `quo`}
#' @export
#' @examples
#' f <- function(i) if (i > 3) i * 9 else i * 10
#' i <- 10
#'
#' # This sort of expression commonly occurs inside a for loop or function
#' # And the failure isn't helpful because you can't see the value of i
#' # that caused the problem:
#' show_failure(expect_equal(f(i), i * 10))
#'
#' # To overcome this issue, testthat allows you to unquote expressions using
#' # !!. This causes the failure message to show the value rather than the
#' # variable name
#' show_failure(expect_equal(f(!!i), !!(i * 10)))
quasi_label <- function(quo, label = NULL, arg = NULL) {
  if (is.null(arg)) {
    arg <- substitute(quo)
    if (is_call(arg, "enquo")) {
      arg <- arg[[2]]
    }
    arg <- as_label(arg)
  }

  force(quo)
  if (quo_is_missing(quo)) {
    cli::cli_abort(
      "argument {.arg {arg}} is missing, with no default.",
      call = caller_env()
    )
  }

  expr <- quo_get_expr(quo)
  value <- eval_bare(expr, quo_get_env(quo))
  label <- label %||% expr_label(expr)

  labelled_value(value, label)
}

labelled_value <- function(value, label) {
  if (missing(value)) {
    list(val = missing_arg(), lab = label)
  } else {
    list(val = value, lab = label)
  }
}

quasi_capture <- function(.quo, .label, .capture, ...) {
  act <- list()
  act$lab <- .label %||% quo_label(.quo)
  act$cap <- .capture(
    act$val <- eval_bare(quo_get_expr(.quo), quo_get_env(.quo)),
    ...
  )

  act
}

expr_label <- function(x) {
  if (is_syntactic_literal(x)) {
    deparse1(x)
  } else if (is.name(x)) {
    paste0("`", as.character(x), "`")
  } else if (is_call(x)) {
    chr <- deparse(x)
    if (length(chr) > 1) {
      if (is_call(x, "function")) {
        x[[3]] <- quote(...)
      } else if (is_call_infix(x)) {
        left <- deparse(x[[2]], width.cutoff = 29)
        right <- deparse(x[[3]], width.cutoff = 28)

        if (length(left) > 1) {
          x[[2]] <- quote(expr = ...)
        }
        if (length(right) > 1) {
          x[[3]] <- quote(expr = ...)
        }
      } else {
        x <- call2(x[[1]], quote(expr = ...))
      }
    }
    paste0("`", deparse1(x), "`")
  } else {
    # Any other object that's been inlined in
    x <- deparse(x)
    if (length(x) > 1) {
      x <- paste0(x[[1]], "...)")
    }
    x
  }
}

is_call_infix <- function(x) {
  if (!is_call(x, n = 2)) {
    return(FALSE)
  }

  fn <- x[[1]]
  if (!is_symbol(fn)) {
    return(FALSE)
  }

  name <- as_string(fn)
  base <- c(
    ":",
    "::",
    ":::",
    "$",
    "@",
    "^",
    "*",
    "/",
    "+",
    "-",
    ">",
    ">=",
    "<",
    "<=",
    "==",
    "!=",
    "!",
    "&",
    "&&",
    "|",
    "||",
    "~",
    "<-",
    "<<-"
  )
  name %in% base || grepl("^%.*%$", name)
}
